home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / LWP / Protocol / gopher.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  4.8 KB  |  194 lines
  1.  
  2.  
  3. package LWP::Protocol::gopher;
  4.  
  5. require LWP::Protocol;
  6. require LWP::Socket;
  7. require HTTP::Request;
  8. require HTTP::Response;
  9. require HTTP::Status;
  10.  
  11. use Carp;
  12.  
  13. @ISA = qw(LWP::Protocol);
  14.  
  15.  
  16. %gopher2mimetype = (
  17.     '0' => 'text/plain',                # 0 file
  18.     '1' => 'text/html',                 # 1 menu
  19.     '4' => 'application/mac-binhex40',  # 4 BinHexed Macintosh file
  20.     '5' => 'application/zip',           # 5 DOS binary archive of some sort
  21.     '6' => 'application/octet-stream',  # 6 UNIX uuencoded file.
  22.     '7' => 'text/html',                 # 7 Index-Search server
  23.     '9' => 'application/octet-stream',  # 9 binary file
  24.     'h' => 'text/html',                 # html
  25.     'g' => 'image/gif',                 # gif
  26.     'I' => 'image/*',                   # some kind of image
  27. );
  28.  
  29. %gopher2encoding = (
  30.     '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
  31. );
  32.  
  33. sub request
  34. {
  35.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  36.  
  37.     LWP::Debug::trace('()');
  38.  
  39.     $size = 4096 unless $size;
  40.  
  41.     if (defined $proxy)
  42.     {
  43.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  44.                   'You can not proxy through the gopher';
  45.     }
  46.  
  47.     my $url = $request->url;
  48.     if ($url->scheme ne 'gopher') {
  49.     my $scheme = $url->scheme;
  50.     return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  51.                "LWP::Protocol::gopher::request called for '$scheme'";
  52.     }
  53.  
  54.     $method = $request->method;
  55.  
  56.     unless ($method eq 'GET' || $method eq 'HEAD') {
  57.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  58.                   'Library does not allow method ' .
  59.                   "$method for 'gopher:' URLs";
  60.     }
  61.  
  62.     my $gophertype = $url->gtype;
  63.     unless (exists $gopher2mimetype{$gophertype}) {
  64.     return new HTTP::Response &HTTP::Status::RC_NOT_IMPLEMENTED,
  65.                   'Library does not support gophertype ' .
  66.                   $gophertype;
  67.     }
  68.  
  69.     my $response = new HTTP::Response &HTTP::Status::RC_OK,
  70.                       'Document follows';
  71.     $response->header('MIME-Version' => '1.0');
  72.     $response->header('Content-type' => $gopher2mimetype{$gophertype}
  73.                     || 'text/plain');
  74.     $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
  75.     if exists $gopher2encoding{$gophertype};
  76.  
  77.     if ($method eq 'HEAD') {
  78.     $response->header('X-Warning' => 'Client answer only');
  79.     return $response;
  80.     }
  81.     
  82.     if ($gophertype eq '7' && ! $url->search) {
  83.       return $self->collect_once($arg, $response, <<"EOT");
  84. <HEAD>
  85. <TITLE>Gopher Index</TITLE>
  86. <ISINDEX>
  87. </HEAD>
  88. <BODY>
  89. <H1>$url<BR>Gopher Search</H1>
  90. This is a searchable Gopher index.
  91. Use the search function of your browser to enter search terms.
  92. </BODY>
  93. EOT
  94.     }
  95.  
  96.     my $host = $url->host;
  97.     my $port = $url->port;
  98.  
  99.     my $requestLine = "";
  100.  
  101.     my $selector = $url->selector;
  102.     if (defined $selector) {
  103.     $requestLine .= $selector;
  104.     my $search = $url->search;
  105.     if (defined $search) {
  106.         $requestLine .= "\t$search";
  107.         my $string = $url->string;
  108.         if (defined $string) {
  109.         $requestLine .= "\t$string";
  110.         }
  111.     }
  112.     }
  113.     $requestLine .= "\015\012";
  114.  
  115.  
  116.     my $socket = new LWP::Socket;
  117.     alarm($timeout) if $self->use_alarm and defined $timeout;
  118.  
  119.     $socket->connect($host, $port);
  120.     LWP::Debug::debug('connected');
  121.  
  122.     $socket->write($requestLine, $timeout);
  123.  
  124.     my $user_arg = $arg;
  125.  
  126.     $arg = undef if $gophertype eq '1' || $gophertype eq '7';
  127.  
  128.     $response = $self->collect($arg, $response, sub {
  129.     LWP::Debug::debug('collecting');
  130.     my $content = '';
  131.     my $result = $socket->read(\$content, $size, $timeout);
  132.     LWP::Debug::debug("collected: $content");
  133.     return \$content;
  134.       } );
  135.  
  136.     if ($gophertype eq '1' || $gophertype eq '7') {
  137.     my $content = menu2html($response->content);
  138.     if (defined $user_arg) {
  139.         $response = $self->collect_once($user_arg, $response, $content);
  140.     } else {
  141.         $response->content($content);
  142.     }
  143.     }
  144.  
  145.     $response;
  146. }
  147.  
  148.  
  149. sub gopher2url
  150. {
  151.     my($gophertype, $path, $host, $port) = @_;
  152.  
  153.     my $url;
  154.  
  155.     if ($gophertype eq '8' || $gophertype eq 'T') {
  156.     $url = new URI::URL ($gophertype eq '8' ? 'telnet:' : 'tn3270:');
  157.     $url->user($path) if defined $path;
  158.     } else {
  159.     $path = URI::Escape::uri_escape($path);
  160.     $url = new URI::URL "gopher:/$gophertype$path";
  161.     }
  162.     $url->host($host);
  163.     $url->port($port);
  164.     $url;
  165. }
  166.  
  167. sub menu2html {
  168.     my($menu) = @_;
  169.  
  170.     $menu =~ s/\015//g;  # remove carriage return
  171.     my $tmp = <<"EOT";
  172. <HTML>
  173. <HEAD>
  174.    <TITLE>Gopher menu</TITLE>
  175. </HEAD>
  176. <BODY>
  177. <H1>Gopher menu</H1>
  178. EOT
  179.     for (split("\n", $menu)) {
  180.     last if /^\./;
  181.     my($pretty, $path, $host, $port) = split("\t");
  182.  
  183.     $pretty =~ s/^(.)//;
  184.     my $type = $1;
  185.  
  186.     my $url = gopher2url($type, $path, $host, $port)->as_string;
  187.     $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
  188.     }
  189.     $tmp .= "</BODY>\n</HTML>\n";
  190.     $tmp;
  191. }
  192.  
  193. 1;
  194.